{
  Copyright 2012 Sergey Ostanin

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
}

unit TestCore;

interface

uses
  Classes, SysUtils, MiscUtils;

type
  TSection = class;
  TSectionList = TGenericObjectList<TSection>;
  TResponse = class;
  TResponseClass = class of TResponse;
  TModifierList = class;
  TAlterant = class;
  TAlterantList = class;

  EIncompatibleResponse = class(Exception);

  TQuestion = class
  private
    FSection: TSection; { can be nil }
    FWeight: Integer;
    FResponse: TResponse;
    FModifiers: TModifierList;
    FLaxEvaluation: Boolean;
    procedure SetWeight(Value: Integer);
  protected
    function GetTitle: String; virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    class function GetResponseClass: TResponseClass; virtual; abstract;
    class procedure Spawn(var Question: TQuestion; Alterants: TAlterantList); virtual;
    class function LaxEvaluationByDefault: Boolean; virtual;
    class function Kind: TKind; virtual; abstract;
    function IsResponseCompatible(Candidate: TResponse): Boolean; virtual; abstract;
    procedure CheckResponseCompatible(Candidate: TResponse);
    function Evaluate(Candidate: TResponse): Single; virtual; abstract;
    procedure Assign(Source: TQuestion); virtual;
    function Clone: TQuestion;
    procedure Filter; virtual;
    function Produce(Alterants: TAlterantList): TQuestion;
    function ReplaceString(const OldString, NewString: String): Integer; virtual;
    function Response: TResponse;

    property LaxEvaluation: Boolean read FLaxEvaluation write FLaxEvaluation;
    property Modifiers: TModifierList read FModifiers;
    property Section: TSection read FSection;
    property Title: String read GetTitle;
    property Weight: Integer read FWeight write SetWeight;
  end;
  TQuestionClass = class of TQuestion;
  TQuestionList = TGenericObjectList<TQuestion>;
  TQuestionClassList = TGenericList<TQuestionClass>;

  TResponse = class
  private
    FOnChange: TNotifyEvent;
    FVersion: Int64;
  protected
    procedure Changed;
  public
    constructor Create; virtual;
    procedure Assign(Source: TResponse); virtual;
    procedure Clear;
    function Clone: TResponse;

    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Version: Int64 read FVersion;
  end;

  TSection = class
  private
    FParent: TSection; { can be nil }
    FName: String;
    FQuestions: TQuestionList;
    FSections: TSectionList;
    FModifiers: TModifierList;
    function GetQuestionCount: Integer;
    procedure CheckQuestionIndex(Index: Integer);
    function GetQuestions(Index: Integer): TQuestion;
    procedure CheckSectionIndex(Index: Integer);
    function GetSectionCount: Integer;
    function GetSections(Index: Integer): TSection;
  public
    constructor Create;
    destructor Destroy; override;
    class function GetFriendlyName(const Name: String): String;
    procedure AddQuestion(Question: TQuestion);
    function ExtractQuestion(Index: Integer): TQuestion;
    procedure AddSection(Section: TSection);
    procedure GetChildSections(SectionList: TSectionList; IncludeSelf: Boolean);
    procedure GetCompleteQuestionList(QuestionList: TQuestionList);

    property Modifiers: TModifierList read FModifiers;
    property Name: String read FName write FName;
    property Parent: TSection read FParent;
    property QuestionCount: Integer read GetQuestionCount;
    property Questions[Index: Integer]: TQuestion read GetQuestions;
    property SectionCount: Integer read GetSectionCount;
    property Sections[Index: Integer]: TSection read GetSections;
  end;

  TModifier = class
  public
    constructor Create; virtual;
    class function GetTitle: String; virtual; abstract;
    class function IsLegacy: Boolean; virtual;
    class function IsApplicableTo(QuestionKind: TKind): Boolean; virtual;
    procedure Apply(var Question: TQuestion; Alterants: TAlterantList); virtual; abstract;
    procedure Assign(Source: TModifier); virtual;
    function Clone: TModifier;
  end;
  TModifierClass = class of TModifier;
  TModifierClassArray = array of TModifierClass;

  TModifierList = class
  private type
    TRawModifierList = TGenericObjectList<TModifier>;
  private
    FModifiers: TRawModifierList;
    function GetCount: Integer;
    procedure CheckModifierIndex(Index: Integer);
    function GetModifiers(Index: Integer): TModifier;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(Modifier: TModifier);
    procedure Delete(Index: Integer);
    procedure Clear;
    procedure Assign(Source: TModifierList);
    function Clone: TModifierList;
    procedure Exchange(Index1, Index2: Integer);
    procedure Apply(var Question: TQuestion; Alterants: TAlterantList);
    function ContainsInstanceOf(ModifierClass: TModifierClass): Boolean;

    property Count: Integer read GetCount;
    property Modifiers[Index: Integer]: TModifier read GetModifiers; default;
  end;

  TAlterant = class
  public
    constructor Create; virtual;
    procedure Apply(var Question: TQuestion); virtual; abstract;
  end;

  TAlterantList = class
  private type
    TRawAlterantList = TGenericObjectList<TAlterant>;
  private
    FAlterants: TRawAlterantList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Apply(var Question: TQuestion);
    procedure Add(Alterant: TAlterant);
  end;

  TTest = class
  private
    FSection: TSection;
  public
    constructor Create;
    destructor Destroy; override;

    property Section: TSection read FSection;
  end;

implementation

resourcestring
  SNoTitle = '<untitled>';

{ TAlterantList }

constructor TAlterantList.Create;
begin
  inherited;
  FAlterants := TRawAlterantList.Create;
end;

destructor TAlterantList.Destroy;
begin
  FreeAndNil(FAlterants);
  inherited;
end;

procedure TAlterantList.Apply(var Question: TQuestion);
var
  a: TAlterant;
begin
  for a in FAlterants do
    a.Apply(Question);
end;

procedure TAlterantList.Add(Alterant: TAlterant);
begin
  FAlterants.AddSafely(Alterant);
end;

{ TQuestion }

procedure TQuestion.Assign(Source: TQuestion);
begin
  Assert( ClassType = Source.ClassType );

  FWeight := Source.FWeight;
  FResponse.Assign(Source.FResponse);
  FModifiers.Assign(Source.FModifiers);
  FLaxEvaluation := Source.FLaxEvaluation;
end;

constructor TQuestion.Create;
begin
  inherited;
  FWeight := 1;
  FResponse := GetResponseClass.Create;
  FModifiers := TModifierList.Create;
  FLaxEvaluation := LaxEvaluationByDefault;
end;

function TQuestion.Response: TResponse;
begin
  Result := FResponse;
end;

function TQuestion.Clone: TQuestion;
begin
  Result := TQuestionClass(ClassType).Create;
  try
    Result.Assign(Self);
  except
    Result.Free;
    raise;
  end;
end;

destructor TQuestion.Destroy;
begin
  FreeAndNil(FResponse);
  FreeAndNil(FModifiers);
  inherited;
end;

procedure TQuestion.SetWeight(Value: Integer);
begin
  if Value <= 0 then
    raise Exception.CreateFmt('Incorrect weight: %d.', [Value]);
  FWeight := Value;
end;

function TQuestion.GetTitle: String;
begin
  Result := '';
end;

class procedure TQuestion.Spawn(var Question: TQuestion; Alterants: TAlterantList);
begin
  { do nothing }
end;

procedure TQuestion.Filter;
begin
  FModifiers.Clear;
  FLaxEvaluation := FALSE;
end;

procedure TQuestion.CheckResponseCompatible(Candidate: TResponse);
begin
  if not IsResponseCompatible(Candidate) then
    raise EIncompatibleResponse.Create('Incompatible response.');
end;

function TQuestion.Produce(Alterants: TAlterantList): TQuestion;
var
  s: TSection;
begin
  Result := Clone;
  try
    Result.Spawn(Result, Alterants);
    FModifiers.Apply(Result, Alterants);

    s := FSection;
    while s <> nil do
    begin
      s.FModifiers.Apply(Result, Alterants);
      s := s.FParent;
    end;
  except
    Result.Free;
    raise;
  end;
end;

function TQuestion.ReplaceString(const OldString, NewString: String): Integer;
{ Returns the number of substitutions performed. }
begin
  Result := 0;
end;

class function TQuestion.LaxEvaluationByDefault: Boolean;
begin
  Result := FALSE;
end;

{ TResponse }

procedure TResponse.Assign(Source: TResponse);
begin
  Assert( ClassType = Source.ClassType );
end;

procedure TResponse.Clear;
var
  EmptyResponse: TResponse;
begin
  EmptyResponse := TResponseClass(ClassType).Create;
  try
    Assign(EmptyResponse);
  finally
    EmptyResponse.Free;
  end;
end;

function TResponse.Clone: TResponse;
begin
  Result := TResponseClass(ClassType).Create;
  try
    Result.Assign(Self);
  except
    Result.Free;
    raise;
  end;
end;

constructor TResponse.Create;
begin
  inherited;
  { do nothing }
end;

procedure TResponse.Changed;
begin
  Inc(FVersion);
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

{ TSection }

procedure TSection.AddQuestion(Question: TQuestion);
begin
  Assert( Question.FSection = nil );
  Question.FSection := Self;
  FQuestions.AddSafely(Question);
end;

procedure TSection.AddSection(Section: TSection);
begin
  Assert( Section.FParent = nil );
  Section.FParent := Self;
  FSections.AddSafely(Section);
end;

procedure TSection.CheckQuestionIndex(Index: Integer);
begin
  Assert( Index >= 0 );
  Assert( Index < QuestionCount );
end;

procedure TSection.CheckSectionIndex(Index: Integer);
begin
  Assert( Index >= 0 );
  Assert( Index < SectionCount );
end;

constructor TSection.Create;
begin
  inherited;
  FQuestions := TQuestionList.Create;
  FSections := TSectionList.Create;
  FModifiers := TModifierList.Create;
end;

destructor TSection.Destroy;
begin
  FreeAndNil(FQuestions);
  FreeAndNil(FSections);
  FreeAndNil(FModifiers);
  inherited;
end;

function TSection.ExtractQuestion(Index: Integer): TQuestion;
begin
  CheckQuestionIndex(Index);
  Result := FQuestions.Extract(FQuestions[Index]);
  Result.FSection := nil;
end;

class function TSection.GetFriendlyName(const Name: String): String;
begin
  if Name = '' then
    Result := SNoTitle
  else
    Result := Name;
end;

function TSection.GetQuestionCount: Integer;
begin
  Result := FQuestions.Count;
end;

function TSection.GetQuestions(Index: Integer): TQuestion;
begin
  CheckQuestionIndex(Index);
  Result := FQuestions[Index];
end;

function TSection.GetSectionCount: Integer;
begin
  Result := FSections.Count;
end;

function TSection.GetSections(Index: Integer): TSection;
begin
  CheckSectionIndex(Index);
  Result := FSections[Index];
end;

procedure TSection.GetChildSections(SectionList: TSectionList;
  IncludeSelf: Boolean);
var
  s: TSection;
begin
  if IncludeSelf then
    SectionList.Add(Self);
  for s in FSections do
    s.GetChildSections(SectionList, TRUE);
end;

procedure TSection.GetCompleteQuestionList(QuestionList: TQuestionList);

  procedure ProcessSection(Section: TSection);
  var
    q: TQuestion;
    s: TSection;
  begin
    for q in Section.FQuestions do
      QuestionList.Add(q);
    for s in Section.FSections do
      ProcessSection(s);
  end;

begin
  ProcessSection(Self);
end;

{ TModifierList }

procedure TModifierList.Add(Modifier: TModifier);
begin
  FModifiers.AddSafely(Modifier);
end;

procedure TModifierList.Apply(var Question: TQuestion; Alterants: TAlterantList);
var
  m: TModifier;
begin
  for m in FModifiers do
    m.Apply(Question, Alterants);
end;

procedure TModifierList.Assign(Source: TModifierList);
var
  m: TModifier;
begin
  Clear;
  for m in Source.FModifiers do
    Add(m.Clone);
end;

procedure TModifierList.CheckModifierIndex(Index: Integer);
begin
  Assert( Index >= 0 );
  Assert( Index < Count );
end;

procedure TModifierList.Clear;
begin
  FModifiers.Clear;
end;

function TModifierList.Clone: TModifierList;
begin
  Result := TModifierList.Create;
  try
    Result.Assign(Self);
  except
    Result.Free;
    raise;
  end;
end;

constructor TModifierList.Create;
begin
  inherited;
  FModifiers := TRawModifierList.Create;
end;

procedure TModifierList.Delete(Index: Integer);
begin
  CheckModifierIndex(Index);
  FModifiers.Delete(Index);
end;

destructor TModifierList.Destroy;
begin
  FreeAndNil(FModifiers);
  inherited;
end;

function TModifierList.GetCount: Integer;
begin
  Result := FModifiers.Count;
end;

function TModifierList.GetModifiers(Index: Integer): TModifier;
begin
  CheckModifierIndex(Index);
  Result := FModifiers[Index];
end;

procedure TModifierList.Exchange(Index1, Index2: Integer);
begin
  CheckModifierIndex(Index1);
  CheckModifierIndex(Index2);
  FModifiers.Exchange(Index1, Index2);
end;

function TModifierList.ContainsInstanceOf(ModifierClass: TModifierClass): Boolean;
var
  m: TModifier;
begin
  Result := FALSE;
  for m in FModifiers do
    if m.InheritsFrom(ModifierClass) then
    begin
      Result := TRUE;
      Break;
    end;
end;

{ TModifier }

procedure TModifier.Assign(Source: TModifier);
begin
  Assert( ClassType = Source.ClassType );
end;

function TModifier.Clone: TModifier;
begin
  Result := TModifierClass(ClassType).Create;
  try
    Result.Assign(Self);
  except
    Result.Free;
    raise;
  end;
end;

constructor TModifier.Create;
begin
  inherited;
  { do nothing }
end;

class function TModifier.IsLegacy: Boolean;
begin
  Result := FALSE;
end;

class function TModifier.IsApplicableTo(QuestionKind: TKind): Boolean;
begin
  Result := TRUE;
end;

{ TAlterant }

constructor TAlterant.Create;
begin
  inherited;
  { do nothing }
end;

{ TTest }

constructor TTest.Create;
begin
  inherited;
  FSection := TSection.Create;
end;

destructor TTest.Destroy;
begin
  FreeAndNil(FSection);
  inherited;
end;

end.
